home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / faq-s.zip / DATABASE.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-13  |  17KB  |  670 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit database;
  5.  
  6. interface
  7.  
  8. uses gentypes,configrt,gensubs,subs1,subs2,overret1,statret,userret,modem;
  9.  
  10. procedure datamenu;
  11.  
  12. implementation
  13.  
  14. procedure datamenu;
  15. var curbase:baserec;
  16.     curbasenum:integer;
  17.  
  18. procedure packentry (var p:parsedentry; var a:anystr);
  19. var cnt:integer;
  20. begin
  21.   a:='';
  22.   for cnt:=1 to curbase.numcats do
  23.     if length(a)+length(p[cnt])>254 then begin
  24.       writeln ('Entry to big, truncated.');
  25.       exit
  26.     end else a:=a+p[cnt]+#1
  27. end;
  28.  
  29. procedure parseentry (var oa:anystr; var p:parsedentry);
  30. var d,cnt:integer;
  31.     a:anystr;
  32. begin
  33.   a:=oa;
  34.   for cnt:=1 to curbase.numcats do begin
  35.     d:=pos(#1,a);
  36.     if d=0 then p[cnt]:=''
  37.      else begin
  38.         p[cnt]:=copy(a,1,d-1);
  39.         a:=copy(a,d+1,255)
  40.      end
  41.   end
  42. end;
  43.  
  44. procedure makenewbase;
  45.  
  46.   function getnumber (r1,r2:integer; txt:mstr):integer;
  47.   var t:integer;
  48.   begin
  49.     repeat
  50.       writestr (txt+':');
  51.       t:=valu(input);
  52.       if (t<r1) or (t>r2) then
  53.         writeln (^R'Sorry, must be from '^S,r1,^R' to '^S,r2,^R'.')
  54.     until (t>=r1) and (t<=r2);
  55.     getnumber:=t
  56.   end;
  57.  
  58. var n,cnt:integer;
  59.     b:baserec;
  60.     p:parsedentry;
  61. begin
  62.   n:=filesize(ddfile)+1;
  63.   writehdr ('Create Database Number '+strr(n));
  64.   writestr ('Database Name:');
  65.   if length(input)=0 then exit;
  66.   b.basename:=input;
  67.   writestr ('Access Level:');
  68.   if length(input)=0
  69.     then b.level:=1
  70.     else b.level:=valu(input);
  71.   b.numcats:=getnumber (1,maxcats,'Number of categories');
  72.   b.numents:=0;
  73.   for cnt:=1 to b.numcats do begin
  74.     writestr ('Category #'+strr(cnt)+' Name:');
  75.     if length(input)=0 then exit;
  76.     p[cnt]:=input
  77.   end;
  78.   curbase:=b;
  79.   packentry (p,b.catnames);
  80.   seek (ddfile,n-1);
  81.   write (ddfile,b);
  82.   writeln ('Database created!');
  83.   writelog (7,2,b.basename);
  84.   curbase:=b;
  85.   curbasenum:=n
  86. end;
  87.  
  88. procedure nobases;
  89. begin
  90.   rewrite (ddfile);
  91.   writeln ('No Databases exist!');
  92.   if not issysop then exit;
  93.   writestr (^R'Create first Database now? ['^P'y/N'^R']: *');
  94.   if not yes then exit;
  95.   makenewbase
  96. end;
  97.  
  98. procedure openddfile;
  99. begin
  100.   assign (ddfile,bbsdatadir+'DataDir.dat');
  101.   reset (ddfile);
  102.   if ioresult<>0
  103.     then nobases
  104.     else begin
  105.       reset (ddfile);
  106.       if filesize (ddfile)<1 then begin
  107.         close (ddfile);
  108.         nobases
  109.       end
  110.     end
  111. end;
  112.  
  113. procedure writecurbase;
  114. begin
  115.   seek (ddfile,curbasenum-1);
  116.   write (ddfile,curbase)
  117. end;
  118.  
  119. procedure readcurbase;
  120. begin
  121.   seek (ddfile,curbasenum-1);
  122.   read (ddfile,curbase)
  123. end;
  124.  
  125. procedure openefile;
  126. var i:integer;
  127. begin
  128.   readcurbase;
  129.   if isopen(efile) then close(efile);
  130.   i:=ioresult;
  131.   assign (efile,bbsdatadir+'DataBase.'+strr(curbasenum));
  132.   reset (efile);
  133.   if ioresult<>0 then rewrite (efile);
  134.   curbase.numents:=filesize(efile);
  135.   writecurbase
  136. end;
  137.  
  138. function getparsedentry (var p:parsedentry):boolean;
  139. var cnt:integer;
  140.     pr:parsedentry;
  141.     nonblank:boolean;
  142. begin
  143.   nonblank:=false;
  144.   parseentry (curbase.catnames,pr);
  145.   writeln ('(*=',unam,')');
  146.   for cnt:=1 to curbase.numcats do begin
  147.     writestr (pr[cnt]+': &');
  148.     if length(input)>0 then nonblank:=true;
  149.     if input='*'
  150.       then p[cnt]:=unam
  151.       else p[cnt]:=input
  152.   end;
  153.   getparsedentry:=nonblank
  154. end;
  155.  
  156. function getentry (var a:anystr):boolean;
  157. var p:parsedentry;
  158. begin
  159.   getentry:=getparsedentry (p);
  160.   packentry (p,a)
  161. end;
  162.  
  163. const shownumbers:boolean=false;
  164. procedure showparsedentry (var p:parsedentry);
  165. var cnt:integer;
  166.     pr:parsedentry;
  167. begin
  168.   parseentry (curbase.catnames,pr);
  169.   for cnt:=1 to curbase.numcats do begin
  170.     if shownumbers then write (cnt,'. ');
  171.     writeln (pr[cnt],': '^S,p[cnt]);
  172.     if break then exit
  173.   end;
  174.   shownumbers:=false
  175. end;
  176.  
  177. procedure showentry (var b:anystr);
  178. var p:parsedentry;
  179. begin
  180.   parseentry (b,p);
  181.   showparsedentry (p)
  182. end;
  183.  
  184. procedure showentrynum (var art:anystr; n:integer);
  185. begin
  186.   writeln (^M^R,'Entry '^S,n,^R' of '^S,curbase.numents,^R);
  187.   showentry (art)
  188. end;
  189.  
  190. function noentries:boolean;
  191. begin
  192.   if curbase.numents>0 then noentries:=false
  193.    else begin
  194.      writeln ('Sorry, Database is empty!');
  195.      noentries:=true
  196.    end
  197. end;
  198.  
  199. procedure changeentryrec (var s:entryrec);
  200. var p:parsedentry;
  201.     c:integer;
  202.     done:boolean;
  203. begin
  204.   parseentry (s.data,p);
  205.   repeat
  206.     shownumbers:=true;
  207.     showparsedentry (p);
  208.     writestr (^M'Category number to change [CR to exit]:');
  209.     done:=length(input)=0;
  210.     if not done then begin
  211.       c:=valu(input);
  212.       if (c>0) and (c<=curbase.numcats) then begin
  213.         writestr ('New value [*=Your name, CR to leave unchanged]: &');
  214.         if length(input)<>0 then if input='*'
  215.          then p[c]:=unam
  216.          else p[c]:=input
  217.       end
  218.     end
  219.   until done;
  220.   packentry (p,s.data)
  221. end;
  222.  
  223. procedure adddata;
  224. var e:entryrec;
  225. begin
  226.   writehdr ('Add an entry');
  227.   if not getentry (e.data) then begin
  228.     writeln ('- Blank Entry! -');
  229.     exit
  230.   end;
  231.   writestr (^M'Make changes? [Y/N/X]: *');
  232.   if length(input)<>0 then
  233.     case upcase(input[1]) of
  234.       'X':begin
  235.             writestr ('Entry not added.');
  236.             exit
  237.           end;
  238.       'Y':changeentryrec (e)
  239.     end;
  240.   e.when:=now;
  241.   e.addedby:=unum;
  242.   seek (efile,curbase.numents);
  243.   write (efile,e);
  244.   curbase.numents:=curbase.numents+1;
  245.   writecurbase;
  246.   if dbases>32760 then dbases:=0;
  247.   dbases:=dbases+1
  248. end;
  249.  
  250. procedure listdata;
  251. var cnt,f,l:integer;
  252.     e:entryrec;
  253. begin
  254.   if noentries then exit;
  255.   writeln;
  256.   parserange (curbase.numents,f,l);
  257.   if f=0 then exit;
  258.   writeln;
  259.   for cnt:=f to l do begin
  260.     seek (efile,cnt-1);
  261.     read (efile,e);
  262.     showentrynum (e.data,cnt);
  263.     if break then exit
  264.   end
  265. end;
  266.  
  267. function getdatanum (txt:mstr):integer;
  268. var n:integer;
  269. begin
  270.   getdatanum:=0;
  271.   if noentries then exit;
  272.   repeat
  273.     writestr (^M^R'Entry to '^S+txt+^R' ['^S'?/List'^R']:');
  274.     if length(input)=0 then exit;
  275.     if input='?' then begin
  276.       listdata;
  277.       input:=''
  278.     end
  279.   until length(input)>0;
  280.   n:=valu(input);
  281.   if (n>0) and (n<=curbase.numents) then getdatanum:=n
  282. end;
  283.  
  284. function notuseradded (var e:entryrec):boolean;
  285. var b:boolean;
  286. begin
  287.   b:=not ((e.addedby=unum) or issysop);
  288.   notuseradded:=b;
  289.   if b then writestr ('You didn''t add this entry!')
  290. end;
  291.  
  292. procedure changedata;
  293. var n:integer;
  294.     e:entryrec;
  295. begin
  296.   n:=getdatanum ('change');
  297.   if n=0 then exit;
  298.   seek (efile,n-1);
  299.   read (efile,e);
  300.   if notuseradded (e) then exit;
  301.   writelog (8,3,copy(e.data,1,pos(#1,e.data)-1));
  302.   changeentryrec (e);
  303.   seek (efile,n-1);
  304.   write (efile,e)
  305. end;
  306.  
  307. procedure deleteit;
  308. var n,cnt:integer;
  309.     e:entryrec;
  310.     p:parsedentry;
  311. begin
  312.   n:=getdatanum ('Delete');
  313.   if n=0 then exit;
  314.   seek (efile,n-1);
  315.   read (efile,e);
  316.   if notuseradded(e) then exit;
  317.   parseentry (e.data,p);
  318.   writelog (8,6,p[1]);
  319.   curbase.numents:=curbase.numents-1;
  320.   writecurbase;
  321.   for cnt:=n to curbase.numents do begin
  322.     seek (efile,cnt);
  323.     read (efile,e);
  324.     seek (efile,cnt-1);
  325.     write (efile,e)
  326.   end;
  327.   seek (efile,curbase.numents);
  328.   truncate (efile);
  329.   if dbases<1 then dbases:=1;
  330.   dbases:=dbases-1;
  331.   if urec.lastdbases<1 then urec.lastdbases:=1;
  332.   urec.lastdbases:=urec.lastdbases-1
  333. end;
  334.  
  335. procedure listbases;
  336. var cnt:integer;
  337.     b:baserec;
  338. begin
  339.   if break then exit;
  340.   writeln (^B^R'[##] [Name]'^M);
  341.   for cnt:=1 to filesize (ddfile) do begin
  342.     seek (ddfile,cnt-1);
  343.     read (ddfile,b);
  344.     if b.level<=ulvl then begin
  345.      write (^P'['^S);
  346.      tab (strr(cnt),2);
  347.      write (^P'] ['^S);
  348.      tab (b.basename,30);
  349.      writeln (^P']'^R)
  350.     end;
  351.     if break then exit
  352.   end;
  353.   writeln;
  354. end;
  355.  
  356. procedure selectdata;
  357. var n:integer;
  358.     b:baserec;
  359. begin
  360.   if length(input)>1 then input:=copy(input,2,255) else
  361.    begin
  362.     listbases;
  363.     repeat
  364.       writestr ('Database Number ['^S'?/List'^P']:');
  365.       if length(input)<1 then exit;
  366.       if input='?' then begin
  367.         listbases;
  368.         input:=''
  369.       end
  370.     until length(input)>0
  371.    end;
  372.   n:=valu(input);
  373.   if (n<1) or (n>filesize(ddfile)) then begin
  374.     writeln ('No such Database: '^S,n);
  375.     if not issysop then exit;
  376.     n:=filesize(ddfile)+1;
  377.     writestr ('Create Database #'+strr(n)+'? [y/n]: *');
  378.     if yes then begin
  379.       writecurbase;
  380.       makenewbase;
  381.       openefile
  382.     end;
  383.     exit
  384.   end;
  385.   seek (ddfile,n-1);
  386.   read (ddfile,b);
  387.   if b.level>ulvl then begin
  388.     reqlevel (b.level);
  389.     exit
  390.   end;
  391.   writecurbase;
  392.   curbasenum:=n;
  393.   openefile
  394. end;
  395.  
  396. procedure searchdata;
  397. var cnt,f,en:integer;
  398.     e:entryrec;
  399.     pattern:anystr;
  400.     p:parsedentry;
  401. begin
  402.   if noentries then exit;
  403.   writestr ('Search for:');
  404.   if length(input)=0 then exit;
  405.   pattern:=input;
  406.   for cnt:=1 to length(pattern) do pattern[cnt]:=upcase(pattern[cnt]);
  407.   for en:=1 to curbase.numents do begin
  408.     seek (efile,en-1);
  409.     read (efile,e);
  410.     parseentry (e.data,p);
  411.     for f:=1 to curbase.numcats do begin
  412.       for cnt:=1 to length(p[f]) do p[f][cnt]:=upcase(p[f][cnt]);
  413.       if pos(pattern,p[f])<>0 then showentrynum (e.data,en)
  414.     end
  415.   end;
  416.   writeln (^M'Search complete.')
  417. end;
  418.  
  419. const beenaborted:boolean=false;
  420.  
  421. function aborted:boolean;
  422. begin
  423.   if beenaborted then begin
  424.     aborted:=true;
  425.     exit
  426.   end;
  427.   aborted:=xpressed or hungupon;
  428.   if xpressed then begin
  429.     beenaborted:=true;
  430.     writeln (^B'Newscan aborted!')
  431.   end
  432. end;
  433.  
  434. procedure newscan;
  435. var first,cnt:integer;
  436.     nd:boolean;
  437.     e:entryrec;
  438. begin
  439.   beenaborted:=false;
  440.   first:=curbase.numents;
  441.   nd:=true;
  442.   while (first>0) and nd do begin
  443.     seek (efile,first-1);
  444.     read (efile,e);
  445.     nd:=e.when>laston;
  446.     if nd then first:=first-1
  447.   end;
  448.   for cnt:=first+1 to curbase.numents do begin
  449.     seek (efile,cnt-1);
  450.     read (efile,e);
  451.     if aborted then exit;
  452.     showentrynum (e.data,cnt)
  453.   end
  454. end;
  455.  
  456. procedure newscanall;
  457. begin
  458.   writeln (^M^R'Scanning since last on as of: ['^S,datestr(laston),^R']'^M);
  459.   writeln ('New-Scanning - Press [X] to Abort.');
  460.   curbasenum:=1;
  461.   while curbasenum<=filesize(ddfile) do begin
  462.     if aborted then exit;
  463.     openefile;
  464.     if curbase.level<=ulvl then begin
  465.       writeln (^B^M^R'Scanning ['^S,curbase.basename,^R']'^M);
  466.       newscan;
  467.       if aborted then exit
  468.     end;
  469.     curbasenum:=curbasenum+1
  470.   end;
  471.   curbasenum:=1;
  472.   openefile;
  473.   writeln (^B'Newscan complete!')
  474. end;
  475.  
  476. procedure l8r;
  477. var b:baserec;
  478.     cnt:integer;
  479. begin
  480.   writestr ('Kill Database - Are you sure? [y/N]: *');
  481.   if not yes then exit;
  482.   writecurbase;
  483.   dbases:=dbases-curbase.numents;
  484.   if dbases<1 then dbases:=1;
  485.   urec.lastdbases:=urec.lastdbases-curbase.numents;
  486.   if urec.lastdbases<1 then urec.lastdbases:=1;
  487.   writeurec;
  488.   close (efile);
  489.   erase (efile);
  490.   for cnt:=curbasenum to filesize(ddfile)-1 do begin
  491.     seek (ddfile,cnt);
  492.     read (ddfile,b);
  493.     seek (ddfile,cnt-1);
  494.     write (ddfile,b);
  495.     assign (efile,bbsdatadir+'Database.'+strr(cnt+1));
  496.     rename (efile,bbsdatadir+'Database.'+strr(cnt))
  497.   end;
  498.   seek (ddfile,filesize(ddfile)-1);
  499.   truncate (ddfile);
  500.   writelog (8,5,'');
  501.   if filesize(ddfile)>0 then begin
  502.     curbasenum:=1;
  503.     openefile
  504.   end
  505. end;
  506.  
  507. procedure datareorder;
  508. var numd,curd,newd:integer;
  509.     b1,b2:baserec;
  510.     f1,f2:file;
  511.     fn1,fn2:sstr;
  512. label exit;
  513. begin
  514.   writecurbase;
  515.   writehdr ('Re-order Databases');
  516.   writelog (8,1,'');
  517.   numd:=filesize (ddfile);
  518.   writeln ('Number of Databases: ',numd);
  519.   for curd:=0 to numd-2 do begin
  520.     repeat
  521.       writestr ('New Database #'+strr(curd+1)+' [?/List, CR/Quit]:');
  522.       if length(input)=0 then goto exit;
  523.       if input='?' then begin
  524.          listbases;
  525.          newd:=-1
  526.       end else begin
  527.          newd:=valu(input)-1;
  528.          if (newd<0) or (newd>=numd) then begin
  529.             writeln ('Not found!  Please re-enter...');
  530.             newd:=-1
  531.          end
  532.       end
  533.     until (newd>0);
  534.     seek (ddfile,curd);
  535.     read (ddfile,b1);
  536.     seek (ddfile,newd);
  537.     read (ddfile,b2);
  538.     seek (ddfile,curd);
  539.     write (ddfile,b2);
  540.     seek (ddfile,newd);
  541.     write (ddfile,b1);
  542.     fn1:=bbsdatadir+'Database.';
  543.     fn2:=fn1+strr(newd+1);
  544.     fn1:=fn1+strr(curd+1);
  545.     assign (f1,fn1);
  546.     assign (f2,fn2);
  547.     rename (f1,'Temp$$$$');
  548.     rename (f2,fn1);
  549.     rename (f1,fn2)
  550.   end;
  551.   exit:
  552.   curbasenum:=1;
  553.   openefile
  554. end;
  555.  
  556. procedure renamebase;
  557. begin
  558.   writeln ('Current name: '^S,curbase.basename);
  559.   writestr ('Enter new name:');
  560.   if length(input)>0 then begin
  561.     curbase.basename:=input;
  562.     writecurbase;
  563.     writelog (8,2,input)
  564.   end
  565. end;
  566.  
  567. procedure levelset;
  568. begin
  569.   writeln ('Current Level: '^S,curbase.level);
  570.   writestr ('Enter new Level:');
  571.   if length(input)>0 then begin
  572.     curbase.level:=valu(input);
  573.     writecurbase;
  574.     writelog (8,4,strr(curbase.level))
  575.   end
  576. end;
  577.  
  578. procedure sysopcommands;
  579. var q:integer;
  580. begin
  581.   writelog (7,1,curbase.basename);
  582.   repeat
  583.     q:=menu ('Database Sysop','DSYSOP','QCDEKOR?');
  584.     case q of
  585.       2:changedata;
  586.       3:deleteit;
  587.       4:levelset;
  588.       5:l8r;
  589.       6:datareorder;
  590.       7:renamebase;
  591.       8:begin
  592. writeln ('C╔═════════════════════════════════════╗Hs');
  593. writeln ('uC║ Database Sysop Section              ║Hs');
  594. writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
  595. writeln ('u═════════════════════════════════╗HC║ [C] s');
  596. writeln ('uChange Data File                ║HC║ [Ds');
  597. writeln ('u] Delete Data File                ║HC║ [s');
  598. writeln ('uE] Set Levels                      ║Hs');
  599. writeln ('uC║ [K] Kill Database                   s');
  600. writeln ('u║HC║ [O] Re-Order Databases       s');
  601. writeln ('u       ║HC║ [Q] Quit              s');
  602. writeln ('u              ║HC║ [R] Rename Datas');
  603. writeln ('ubase                 ║HC║ [?] Views');
  604. writeln ('u This Menu                  ║HC╚═════════════════A');
  605. writeln ('C════════════════════╝');
  606. writeln;
  607. pause;
  608.            end;
  609.     end
  610.   until (q=1) or hungupon or (filesize(ddfile)=0)
  611. end;
  612.  
  613. var q:integer;
  614. begin
  615.   cursection:=databasesysop;
  616.   openddfile;
  617.   if filesize(ddfile)=0 then exit;
  618.   curbasenum:=1;
  619.   seek (ddfile,0);
  620.   read (ddfile,curbase);
  621.   if curbase.level>ulvl then begin
  622.     reqlevel (curbase.level);
  623.     close (ddfile);
  624.     exit
  625.   end;
  626.   openefile;
  627.   writehdr ('Databases');
  628.   repeat
  629.     writeln (^B^M'Active: ['^S,curbase.basename,^R']');
  630.     writeln ('Entries: '^S,curbase.numents);
  631.     q:=menu('Database','DBASE','QA*SLVN%@CD?');
  632.     case q of
  633.       2:adddata;
  634.       3:selectdata;
  635.       4:searchdata;
  636.       5:listdata;
  637.       6:newscan;
  638.       7:newscanall;
  639.       8:sysopcommands;
  640.       9:changedata;
  641.       10:deleteit;
  642.       11:begin
  643. writeln ('C╔═════════════════════════════════════╗Hs');
  644. writeln ('uC║ Database Section                    ║Hs');
  645. writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
  646. writeln ('u═════════════════════════════════╗HC║ [A] s');
  647. writeln ('uAdd Database File               ║HC║ [Cs');
  648. writeln ('u] Change Database File            ║HC║ [s');
  649. writeln ('uD] Delete Database File            ║Hs');
  650. writeln ('uC║ [L] List Database File(s)           s');
  651. writeln ('u║HC║ [N] Newscan all Databases    s');
  652. writeln ('u       ║HC║ [Q] Quit              s');
  653. writeln ('u              ║HC║ [S] Search Datas');
  654. writeln ('ubases                ║HC║ [V] Newss');
  655. writeln ('ucan Current Database        ║HC║ [%] s');
  656. writeln ('uDatabase Sysop Section          ║HC║ [*s');
  657. writeln ('u] Change Active Database          ║HC║ s');
  658. writeln ('u[?] View This Menu                  ║HA');
  659. writeln ('C╚═════════════════════════════════════╝');
  660. writeln;
  661. pause;
  662.          end;
  663.     end
  664.   until hungupon or (q=1) or (filesize(ddfile)=0);
  665.   close (ddfile);
  666.   close (efile)
  667. end;
  668.  
  669. begin
  670. end.